Sub BestandenBinnenhalen()
Dim oWbk As Workbook
Dim sBestand As String
Dim sPad As String
Dim sTargetSheet As String
Dim wsTarget As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
sPad = "C:\CebeoExport" 'de folder met mappen die gedaan moet worden
ChDir sPad
sBestand = Dir("*.xls") 'enkel xls bestanden in die folder mogen in de code gedaan worden
Do While sBestand <> ""
On Error GoTo here
Set oWbk = Workbooks.Open(sPad & "\" & sBestand) 'opent het bestand
'bericht in de statusbalk
Application.StatusBar = "Bezig met " & oWbk.Name & String(3, ".")
'1. naam van het tabblad waarnaar gekopieerd is, is:
''de bestandsnaam
sTargetSheet = oWbk.Name
''doe de .xls eraf
sTargetSheet = Left(sTargetSheet, Len(sTargetSheet) - 4)
''doe de export eraf (we testen of export er wel inzit)
If InStr(sTargetSheet, "export") > 0 Then
sTargetSheet = Replace(sTargetSheet, "export", "", 1, 1)
End If
''zet in hoofdletters
sTargetSheet = UCase(sTargetSheet)
'2. wijs tabblad toe aan variabele
On Error Resume Next
Set wsTarget = ThisWorkbook.Sheets(sTargetSheet)
On Error GoTo 0
'3. kijk of tabblad bestaat, indien niet: doe niets
If wsTarget Is Nothing Then
'doe niets
'kan aangepast worden indien gewenst
Else
'4. bestand klaarmaken voor de lus
''deze macro werd vroeger manueel gedaan
Call BestandKlaarmakenVoorLus(oWbk)
'5. verwijder de huidige rijen in doeltabblad
With wsTarget
.Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).ClearContents
End With
'6. doe het kopiëren
''bronbestand is oWbk
''brontabblad is 1ste tabblad in oWbk (BIJ VERONDERSTELLING)
''bronbereik is A2:F[laatste rij]
''doelbestand is dit bestand (ThisWorkbook gebruiken we)
''doeltabblad is wsTarget
''doelbereik is A2:F[laatste rij]
oWbk.Sheets(1).Range("A2:F" & oWbk.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
wsTarget.Range("A2").PasteSpecial xlPasteValues
'7. update datum in cel A1
wsTarget.Range("A1").Value = Date
'8. selecteer cel A1 op blad wsTarget
Application.Goto wsTarget.Range("A1")
'9. maak Klembord leeg
''procedure: zie onderaan deze module
ClearClipboard
End If
'10. sluit het bronbestand MET wijzigingen opslaan
oWbk.Close SaveChanges:=True
here:
'dit bestand in de lus is klaar, nu het volgende bestand
'de regels sBestand = Dir en Loop zorgen voor de lus
sBestand = Dir
Loop
With Application
.Goto ThisWorkbook.Sheets(1).Range("A1")
.CutCopyMode = False
.StatusBar = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub